home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue27 / ktmbevel / KTMBEVEL.ZIP / Source / ktMBevel.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1997-10-04  |  12.3 KB  |  500 lines

  1. {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
  2. {                                                                                                                                                            }
  3. {    TktMultiBevel    v1.0 10/2/97                                                                                                    }
  4. {                                                                                                                                                            }
  5. {    The    TktMultiBevel    is an    enhanced Bevel with    the    possibility    to choose                }
  6. {                                                                                                                                                            }
  7. {    -    BorderColor,                                                                                                                            }
  8. {    -    BorderWidth,                                                                                                                            }
  9. {    -    BevelColor,                                                                                                                                }
  10. {    -    BevelWidth a.o.m.                                                                                                                    }
  11. {                                                                                                                                                            }
  12. {    This component is    freeware.    Do what    you    want with    it,    but    use    it at    your        }
  13. {    own    risk.                                                                                                                                        }
  14. {                                                                                                                                                            }
  15. {    For    Delphi 1 use the ressource file    *.d16, for Delphi    2    and    3    *.d32.                }
  16. {    It's not necessary to    rename it.                                                                                        }
  17. {                                                                                                                                                            }
  18. {                                                                                                                                                            }
  19. {    It is    the    first    release    of my    first    component.                                                            }
  20. {    I    hope for tips.                                                                                                                        }
  21. {                                                                                                                                                            }
  22. {    e-mail:    MuK.Thaler@T-Online.de                                                                                            }
  23. {    Kerstin    Thaler                                                                                                                            }
  24. {                                                                                                                                                            }
  25. {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
  26.  
  27. unit ktMBevel;
  28.  
  29. interface
  30.  
  31. uses
  32.     {$IFDEF    Win32} Windows,    {$ELSE}    WinTypes,    WinProcs,    {$ENDIF} Classes,
  33.     ExtCtrls,    Controls,    Graphics,    SysUtils;
  34.  
  35. type
  36.     TBevelStyle    =    (bstLowered, bstNone,    bstRaised);
  37.     TBevelShape    =    (bspBottomLine,    bspLeftLine, bspRect,    bspRightLine,    bspTopLine);
  38.     TBevelWidth    =    1..MaxInt;
  39.     TBorderWidth = 0..MaxInt;
  40.  
  41. type
  42.     TktMultiBevel    =    class(TGraphicControl)
  43.     private
  44.         FBevelInner: TBevelStyle;
  45.         FBevelOuter: TBevelStyle;
  46.         FBevelWidth: TBevelWidth;
  47.         FBorderWidth:    TBorderWidth;
  48.         FColor:    TColor;
  49.         FColorFixed: Boolean;
  50.         FColorHighlight: TColor;
  51.         FColorShadow:    TColor;
  52.         FShape:    TBevelShape;
  53.         FTransparent:    Boolean;
  54.         procedure    SetBevelInner(Value: TBevelStyle);
  55.         procedure    SetBevelOuter(Value: TBevelStyle);
  56.         procedure    SetBevelWidth(Value: TBevelWidth);
  57.         procedure    SetBorderWidth(Value:    TBorderWidth);
  58.         procedure    SetColor(Value:    TColor);
  59.         procedure    SetColorHighlight(Value: TColor);
  60.         procedure    SetColorFixed(Value: Boolean);
  61.         procedure    SetColorShadow(Value:    TColor);
  62.         procedure    SetShape(Value:    TBevelShape);
  63.         procedure    SetTransparent(Value:    Boolean);
  64.     protected
  65.         procedure    Paint; override;
  66.     public
  67.         constructor    Create(AOwner: TComponent);    override;
  68.         destructor Destroy;    override;
  69.     published
  70.         property Align;
  71.         property BevelInner: TBevelStyle read    FBevelInner    write    SetBevelInner
  72.                                 default    bstNone;
  73.         property BevelOuter: TBevelStyle read    FBevelOuter    write    SetBevelOuter
  74.                                 default    bstLowered;
  75.         property BevelWidth: TBevelWidth read    FBevelWidth    write    SetBevelWidth    default    1;
  76.         property BorderWidth:    TBorderWidth read    FBorderWidth write SetBorderWidth
  77.                                 default    0;
  78.         property Color:    TColor read    FColor write SetColor    default    clBtnFace;
  79.         property ColorFixed: Boolean read    FColorFixed    write    SetColorFixed    default    True;
  80.         property ColorHighlight: TColor    read FColorHighlight write SetColorHighlight
  81.                                 default    clBtnHighlight;
  82.         property ColorShadow:    TColor read    FColorShadow write SetColorShadow
  83.                                 default    clBtnShadow;
  84.         property ParentShowHint;
  85.         property Shape:    TBevelShape    read FShape    write    SetShape default bspRect;
  86.         property ShowHint;
  87.         property Transparent:    Boolean    read FTransparent    write    SetTransparent
  88.                                 default    False;
  89.         property Visible;
  90. end;
  91.  
  92. procedure    Register;
  93.  
  94.  
  95. implementation
  96.  
  97. {$IFDEF    Win32}
  98.     {$R    *.d32}
  99. {$ELSE}
  100.     {$R    *.d16}
  101. {$ENDIF}
  102.  
  103.  
  104. procedure    Register;
  105. begin
  106.     RegisterComponents('Samples',[TktMultiBevel]);
  107. end;
  108.  
  109. {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
  110.  
  111. {    Utilities    }
  112.  
  113. function Min(X,    Y: Integer): Integer;
  114. begin
  115.     if X < Y then    Result :=    X    else Result    := Y;
  116. end;
  117.  
  118. function Max(X,    Y: Integer): Integer;
  119. begin
  120.     if X > Y then    Result :=    X    else Result    := Y;
  121. end;
  122.  
  123. function GetColorHighlight(BaseColor: TColor): TColor;
  124. begin
  125.   Result := RGB(
  126.     Min(GetRValue(ColorToRGB(BaseColor)) + 64, 255),
  127.     Min(GetGValue(ColorToRGB(BaseColor)) + 64, 255),
  128.     Min(GetBValue(ColorToRGB(BaseColor)) + 64, 255)
  129.     );
  130. end;
  131.  
  132. function GetColorShadow(BaseColor: TColor): TColor;
  133. begin
  134.   Result := RGB(
  135.     Max(GetRValue(ColorToRGB(BaseColor)) - 64, 0),
  136.     Max(GetGValue(ColorToRGB(BaseColor)) - 64, 0),
  137.     Max(GetBValue(ColorToRGB(BaseColor)) - 64, 0)
  138.     );
  139. end;
  140.  
  141. {    TktMultiBevel    }
  142.  
  143. constructor    TktMultiBevel.Create(AOwner: TComponent);
  144. begin
  145.     inherited    Create(AOwner);
  146.         FBevelInner:=    bstNone;
  147.         FBevelOuter:=    bstLowered;
  148.         FBevelWidth:=    1;
  149.         FBorderWidth:= 0;
  150.         FColorShadow:= clBtnShadow;
  151.         FColor:= clBtnFace;
  152.         FColorFixed:=    True;
  153.         Height:= 50;
  154.         FShape:= bspRect;
  155.         FColorHighlight:=    clBtnHighlight;
  156.         FTransparent:= False;
  157.         Width:=    50;
  158. end;
  159.  
  160. destructor TktMultiBevel.Destroy;
  161. begin
  162.     inherited    Destroy;
  163. end;
  164.  
  165. procedure    TktMultiBevel.SetBevelInner(Value: TBevelStyle);
  166. begin
  167.     if Value <>    FBevelInner    then
  168.     begin
  169.         FBevelInner    := Value;
  170.         Invalidate;
  171.     end;
  172. end;
  173.  
  174. procedure    TktMultiBevel.SetBevelOuter(Value: TBevelStyle);
  175. begin
  176.     if Value <>    FBevelOuter    then
  177.     begin
  178.         FBevelOuter    := Value;
  179.         Invalidate;
  180.     end;
  181. end;
  182.  
  183. procedure    TktMultiBevel.SetBevelWidth(Value: TBevelWidth);
  184. begin
  185.     if Value <>    FBevelWidth    then
  186.     begin
  187.         FBevelWidth    := Value;
  188.         Invalidate;
  189.     end;
  190. end;
  191.  
  192. procedure    TktMultiBevel.SetBorderWidth(Value:    TBorderWidth);
  193. begin
  194.     if Value <>    FBorderWidth then
  195.     begin
  196.         FBorderWidth :=    Value;
  197.         Invalidate;
  198.     end;
  199. end;
  200.  
  201. procedure    TktMultiBevel.SetColor(Value:    TColor);
  202. begin
  203.     if FColor    <> Value then    FColor :=    Value;
  204.     if not FColorFixed then
  205.     begin
  206.         SetColorShadow(FColorShadow);
  207.         SetColorHighlight(FColorHighlight);
  208.     end
  209.     else
  210.     begin
  211.         if FColor    =    clBtnFace    then
  212.         begin
  213.             FColorHighlight:=    clBtnHighlight;
  214.             FColorShadow:= clBtnShadow;
  215.         end
  216.         else
  217.         begin
  218.             FColorHighlight:=    GetColorHighlight(FColor);
  219.             FColorShadow:= GetColorShadow(FColor);
  220.         end;
  221.     end;
  222.     Invalidate;
  223. end;
  224.  
  225. procedure    TktMultiBevel.SetColorHighlight(Value: TColor);
  226. begin
  227.     if not FColorFixed then
  228.     begin
  229.         if Value <>    FColorHighlight    then
  230.         begin
  231.             FColorHighlight    := Value;
  232.             Invalidate;
  233.         end;
  234.     end;
  235. end;
  236.  
  237. procedure    TktMultiBevel.SetColorShadow(Value:    TColor);
  238. begin
  239.     if not FColorFixed then
  240.     begin
  241.         if Value <>    FColorShadow then
  242.         begin
  243.             FColorShadow :=    Value;
  244.             Invalidate;
  245.         end;
  246.     end;
  247. end;
  248.  
  249. procedure    TktMultiBevel.SetColorFixed(Value: Boolean);
  250. begin
  251.     if Value <>    FColorFixed    then
  252.     begin
  253.         FColorFixed    := Value;
  254.         SetColor(FColor);
  255.         Invalidate;
  256.     end;
  257. end;
  258.  
  259. procedure    TktMultiBevel.SetShape(Value:    TBevelShape);
  260. begin
  261.     if Value <>    FShape then
  262.     begin
  263.         FShape :=    Value;
  264.         Invalidate;
  265.     end;
  266.  
  267. end;
  268.  
  269. procedure    TktMultiBevel.SetTransparent(Value:    Boolean);
  270. begin
  271.     if Value <>    FTransparent then
  272.     begin
  273.         FTransparent :=    Value;
  274.         Invalidate;
  275.     end;
  276. end;
  277.  
  278. procedure    TktMultiBevel.Paint;
  279. var
  280.     RectB, RectA,    RectI: TRect;
  281.     RectBL,    RectBT,    RectBR,    RectBB,    RectIL,    RectIT,    RectIR,    RectIB:    Integer;
  282.     P1,    P2,    P3,    P4,    P5,    P6:    TPoint;
  283.  
  284.     procedure    BevelRect;
  285.     begin
  286.         RectA    := GetClientRect;
  287.         RectBL:= FBevelWidth;
  288.         RectBT:= FBevelWidth;
  289.         RectBR:= max(RectA.Right - FBevelWidth,0);
  290.         RectBB:= max(RectA.Bottom    -    FBevelWidth,0);
  291.         RectB:=    rect(RectBL, RectBT, RectBR, RectBB);
  292.         if BevelOuter    =    bstNone    then
  293.         begin
  294.             RectIL:= FBorderWidth;
  295.             RectIT:= FBorderWidth;
  296.             RectIR:= max(RectA.Right - FBorderWidth,0);
  297.             RectIB:= max(RectA.Bottom    -    FBorderWidth,0);
  298.         end
  299.         else
  300.         begin
  301.             RectIL:= RectBL    +    FBorderWidth;
  302.             RectIT:= RectBT    +    FBorderWidth;
  303.             RectIR:= max(RectBR    -    FBorderWidth,0);
  304.             RectIB:= max(RectBB    -    FBorderWidth,0);
  305.         end;
  306.         RectI:=    rect(RectIL, RectIT, RectIR, RectIB);
  307.  
  308.         with Canvas    do
  309.         begin
  310.             if BevelOuter    =    bstNone    then
  311.             begin
  312.                 if not Transparent then
  313.                     Frame3D(Canvas,    RectA, FColor, FColor, FBorderWidth);
  314.                 case BevelInner    of
  315.                     bstLowered:    Frame3D(Canvas,    RectI, FColorShadow, FColorHighlight,
  316.                                                 FBevelWidth);
  317.                     bstRaised    :    Frame3D(Canvas,    RectI, FColorHighlight,    FColorShadow,
  318.                                                 FBevelWidth);
  319.                 end;
  320.             end
  321.             else
  322.             begin
  323.                 case BevelOuter    of
  324.                     bstLowered:    Frame3D(Canvas,    RectA, FColorShadow, FColorHighlight,
  325.                                                 FBevelWidth);
  326.                     bstRaised    :    Frame3D(Canvas,    RectA, FColorHighlight,    FColorShadow,
  327.                                                 FBevelWidth);
  328.                 end;
  329.                 if not Transparent then
  330.                     Frame3D(Canvas,    RectB, FColor, FColor, FBorderWidth);
  331.                 case BevelInner    of
  332.                     bstLowered:    Frame3D(Canvas,    RectI, FColorShadow, FColorHighlight,
  333.                                                 FBevelWidth);
  334.                     bstRaised    :    Frame3D(Canvas,    RectI, FColorHighlight,    FColorShadow,
  335.                                                 FBevelWidth);
  336.                 end;
  337.             end;
  338.         end;
  339.     end;
  340.  
  341.     procedure    FillBorder;
  342.     var    b: Integer;
  343.     begin
  344.         if not Transparent then
  345.         begin
  346.             if (FBorderWidth mod 2)    =    1    then b:= (FBorderWidth + 1)    div    2
  347.                 else b:= FBorderWidth    div    2;
  348.             case Shape of
  349.                 bspBottomLine:    begin
  350.                                                     P5.x:= BevelWidth;
  351.                                                     P6.x:= RectA.Right - FBevelWidth;
  352.                                                     P5.y:= RectA.Bottom    -    FBevelWidth    -    b;
  353.                                                     P6.y:= P5.y;
  354.                                                 end;
  355.                 bspTopLine        :    begin
  356.                                                     P5.x:= BevelWidth;
  357.                                                     P6.x:= RectA.Right - FBevelWidth;
  358.                                                     P5.y:= FBevelWidth + b;
  359.                                                     P6.y:= P5.y;
  360.                                                 end;
  361.                 bspLeftLine        :    begin
  362.                                                     P5.x:= FBevelWidth + b;
  363.                                                     P6.x:= P5.x;
  364.                                                     P5.y:= BevelWidth;
  365.                                                     P6.y:= RectA.Bottom    -    FBevelWidth;
  366.                                                 end;
  367.                 bspRightLine        :    begin
  368.                                                     P5.x:= RectA.Right - FBevelWidth - b;
  369.                                                     P6.x:= P5.x;
  370.                                                     P5.y:= BevelWidth;
  371.                                                     P6.y:= RectA.Bottom    -    FBevelWidth;
  372.                                                 end;
  373.             end;
  374.             with Canvas    do
  375.             begin
  376.                 Pen.Color:=    FColor;
  377.                 Pen.Width:=    BorderWidth;
  378.                 MoveTo(P5.x,P5.y);
  379.                 LineTo(P6.x,P6.y);
  380.             end;
  381.         end;
  382.     end;
  383.  
  384.     procedure    PaintRightOrBottom;
  385.     var    i: Integer;
  386.     begin
  387.         with Canvas    do
  388.         begin
  389.             Canvas.Pen.Width:= 1;
  390.             for    i:=    1    to FBevelWidth do
  391.                 begin
  392.                     case FBevelOuter of
  393.                         bstRaised    :    Pen.Color:=    FColorHighlight;
  394.                         bstLowered:    Pen.Color:=    FColorShadow;
  395.                     end;
  396.                     PolyLine([P1,P2,P3]);
  397.                     case FBevelOuter of
  398.                         bstRaised    :    Pen.Color:=    FColorShadow;
  399.                         bstLowered:    Pen.Color:=    FColorHighlight;
  400.                     end;
  401.                     dec(P3.y);
  402.                     PolyLine([P1,P4,P3]);
  403.                     inc(P3.y);
  404.                     inc(P1.x);
  405.                     dec(P1.y);
  406.                     inc(P2.x);
  407.                     inc(P2.y);
  408.                     dec(P3.x);
  409.                     inc(P3.y);
  410.                     dec(P4.x);
  411.                     dec(P4.y);
  412.                 end;
  413.                 dec(P3.y);
  414.                 PolyLine([P1,P4,P3]);
  415.             end;
  416.     end;
  417.  
  418.     procedure    BottomLine;
  419.     begin
  420.         if (FBevelOuter    <>    bstNone) or    not    Transparent    then
  421.         begin
  422.             RectA    := GetClientRect;
  423.             P1.x:= 0;
  424.             P1.y:= RectA.Bottom;
  425.             P2.x:= 0;
  426.             P2.y:= RectA.Bottom    -    2*FBevelWidth    -    FBorderWidth;
  427.             P3.x:= RectA.Right;
  428.             P3.y:= P2.y;
  429.             P4.x:= P3.x;
  430.             P4.y:= P1.y;
  431.             FillBorder;
  432.             if FBevelOuter <>    bstNone    then PaintRightOrBottom;
  433.         end;
  434.     end;
  435.  
  436.     procedure    RightLine;
  437.     begin
  438.         if (FBevelOuter    <>    bstNone)    or not Transparent    then
  439.         begin
  440.             RectA    := GetClientRect;
  441.             P1.x:= RectA.Right - 2*FBevelWidth - FBorderWidth;
  442.             P1.y:= RectA.Bottom;
  443.             P2.x:= P1.x;
  444.             P2.y:= 0;
  445.             P3.x:= RectA.Right;
  446.             P3.y:= 0;
  447.             P4.x:= P3.x;
  448.             P4.y:= P1.y;
  449.             FillBorder;
  450.             if FBevelOuter <>    bstNone    then PaintRightOrBottom;
  451.         end;
  452.     end;
  453.  
  454.     procedure    PaintLeftOrTop;
  455.     begin
  456.         RectBL:= 0;
  457.         RectBT:= 0;
  458.         RectB:=    rect(RectBL, RectBT, RectBR, RectBB);
  459.         with Canvas    do
  460.         begin
  461.             FillBorder;
  462.             case BevelOuter    of
  463.                 bstLowered:    Frame3D(Canvas,    RectB, FColorShadow, FColorHighlight,    FBevelWidth);
  464.                 bstRaised    :    Frame3D(Canvas,    RectB, FColorHighlight,    FColorShadow,    FBevelWidth);
  465.             end;
  466.         end;
  467.     end;
  468.  
  469.     procedure    LeftLine;
  470.     begin
  471.         RectA    := GetClientRect;
  472.         RectBR:= FBorderWidth    +    2*FBevelWidth;
  473.         RectBB:= RectA.Bottom;
  474.         PaintLeftOrTop;
  475.     end;
  476.  
  477.     procedure    TopLine;
  478.     begin
  479.         RectA    := GetClientRect;
  480.         RectBR:= RectA.Right;
  481.         RectBB:= FBorderWidth    +    2*FBevelWidth;
  482.         PaintLeftOrTop;
  483.     end;
  484.  
  485.  
  486. begin
  487.     case FShape    of
  488.         bspBottomLine        :    BottomLine;
  489.         bspLeftLine            :    LeftLine;
  490.         bspRect                    :    BevelRect;
  491.         bspRightLine        :    RightLine;
  492.         bspTopLine            :    TopLine;
  493.     end;
  494. end;
  495.  
  496. end.
  497.  
  498.  
  499.  
  500.